home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / m2gem106.lzh / CRYSTAL1.06 / SRC / TOOLBOX / MENUTOOL.MOD < prev    next >
Encoding:
Modula Implementation  |  1993-10-24  |  6.8 KB  |  266 lines
  1. IMPLEMENTATION MODULE MenuTool;
  2.  
  3. (*
  4. Menu Tools.
  5.  
  6. UK __DATE__ __TIME__
  7. *)
  8.  
  9. (*IMP_SWITCHES*)
  10.  
  11. FROM AES      IMPORT Key,SpecialKey,KAlt,KCtrl,KLShift,KRShift,Indirect,
  12.                      Disabled,GUserDef,GBox,GString,StringPtr,StringRange,
  13.                      Root,Nil,ObjectPtr,ObjectIndex,TreePtr,Global,LastOb;
  14. FROM ApplMgr  IMPORT ApplWrite;
  15. FROM EvntMgr  IMPORT MessageBlock,MnSelected;
  16. FROM MenuMgr  IMPORT MenuBar,MenuTNormal;
  17. FROM WindMgr  IMPORT Desk;
  18. FROM RcMgr    IMPORT RcConstrain,GRect;
  19. FROM ObjcTool IMPORT ObjectXYWH,Parent,IndirectObject,
  20.                      NewObjectCallback,DisposeObjectCallback;
  21. FROM RsrcTool IMPORT SpecialChar;
  22. FROM WindTool IMPORT GetWorkXYWH,BeginUpdate,EndUpdate;
  23. FROM PORTAB   IMPORT SIGNEDWORD;
  24. FROM pSTORAGE IMPORT ALLOCATE,DEALLOCATE;
  25. FROM SYSTEM   IMPORT TSIZE;
  26. CAST_IMPORT
  27.  
  28. IMPORT GetObject,SetObject;
  29.  
  30. PROCEDURE ShowMenu(Menu: TreePtr);
  31.  
  32. CONST MagicMenu = 124;
  33.  
  34. VAR Id  : SIGNEDWORD;
  35.     Ob  : ObjectIndex;
  36.     Work: GRect;
  37.     Rect: GRect;
  38.     OldX: SIGNEDWORD;
  39.  
  40. BEGIN
  41.   IF GetObject.Extnd(Menu,Root) # MagicMenu THEN
  42.     SetObject.Extnd(Menu,Root,MagicMenu); (* set flag *)
  43.  
  44.     GetWorkXYWH(Desk,Work);
  45.     Ob:= 7; (* start with the first drop down menu *)
  46.  
  47.     REPEAT
  48.       IF GetObject.Type(Menu,Ob) = GBox THEN (* drop down menu? *)
  49.         ObjectXYWH(Menu,Ob,Rect); (* get absolute coordinates *)
  50.         OldX:= Rect.GX; (* store old x position *)
  51.         RcConstrain(Work,Rect); (* constrain drop down menu *)
  52.         IF Rect.GX # OldX THEN (* changed? *)
  53.           SetObject.X(Menu,Ob,GetObject.X(Menu,Ob) + (Rect.GX - OldX) - 1);
  54.         END; (* GEM desktop decreases here by 8 pixels in case of low rez *)
  55.       END;
  56.       INC(Ob);
  57.     UNTIL LastOb IN GetObject.Flags(Menu,Ob);
  58.   END;
  59.  
  60.   Id:= MenuBar(Menu,1);
  61. END ShowMenu;
  62.  
  63. PROCEDURE HideMenu(Menu: TreePtr);
  64.  
  65. VAR Id: SIGNEDWORD;
  66.  
  67. BEGIN
  68.   Id:= MenuBar(Menu,0);
  69. END HideMenu;
  70.  
  71. PROCEDURE MenuKey(Menu: TreePtr; EvKey: Key; EvSpecial: SpecialKey): BOOLEAN;
  72.  
  73. (* format of a menu entry: "  open... ^O" or "  open... ^O " *)
  74.  
  75. VAR ShortCut   : ARRAY[0..1] OF CHAR;
  76.     MotherTitle: ObjectPtr;
  77.     ChildTitle : ObjectPtr;
  78.     MotherEntry: ObjectPtr;
  79.     ChildEntry : ObjectPtr;
  80.     Msg        : MessageBlock;
  81.     Found      : BOOLEAN;
  82.  
  83.   PROCEDURE TestEntry(Index: ObjectPtr): BOOLEAN;
  84.  
  85.   VAR String: StringPtr;
  86.       i     : StringRange;
  87.  
  88.   BEGIN
  89.     IF GetObject.Type(Menu,Index) = GString THEN
  90.       String:= GetObject.StringPtr(Menu,Index);
  91.     ELSIF GetObject.Type(Menu,Index) = GUserDef THEN
  92.       IF GetObject.Extnd(Menu,Index) = 16 THEN (* Flying Look *)
  93.         IF Indirect IN Menu^[Index].ObFlags THEN
  94.           String:= Menu^[Index].ObSpec.Extension^.Spec.UserBlock^.UBParm^.Parm; (* wouuuh *)
  95.         ELSE
  96.           String:= Menu^[Index].ObSpec.UserBlock^.UBParm^.Parm;
  97.         END;
  98.       END;
  99.     ELSE
  100.       RETURN FALSE;
  101.     END;
  102.  
  103.     IF String # NIL THEN
  104.       i:= 0;
  105.  
  106.       WHILE String^[i] # 0C DO (* go to the end of the string *)
  107.         INC(i);
  108.       END;
  109.  
  110.       DEC(i); (* there was one INC too much *)
  111.  
  112.       IF String^[i] = " " THEN (* skip over last space if there is any *)
  113.         DEC(i);
  114.       END;
  115.  
  116.       IF (String^[i] = ShortCut[1]) AND (String^[i - 1] = ShortCut[0]) THEN
  117.         RETURN TRUE;
  118.       END;
  119.     END;
  120.     RETURN FALSE;
  121.   END TestEntry;
  122.  
  123. BEGIN
  124.   ShortCut[1]:= SpecialChar(EvKey);
  125.  
  126.   IF ShortCut[1] # 0C THEN
  127.     IF KAlt IN EvSpecial THEN
  128.       ShortCut[0]:= 7C; (* "0123◆X" *)
  129.     ELSIF KCtrl IN EvSpecial THEN
  130.       ShortCut[0]:= 136C; (* "0123^X" *)
  131.     ELSIF SpecialKey{KLShift,KRShift} * EvSpecial # SpecialKey{} THEN
  132.       ShortCut[0]:= 1C; (* "0123⇧X" *)
  133.     ELSE
  134.       ShortCut[0]:= " "; (* "0123 X" *)
  135.     END;
  136.  
  137.     BeginUpdate;
  138.     EndUpdate;   (* for certain reasons *)
  139.  
  140.     MotherTitle:= GetObject.Head(Menu,GetObject.Head(Menu,Root));
  141.     ChildTitle:= GetObject.Head(Menu,MotherTitle);
  142.     MotherEntry:= GetObject.Head(Menu,GetObject.Tail(Menu,Root));
  143.     ChildEntry:= GetObject.Head(Menu,MotherEntry);
  144.  
  145.     Found:= FALSE;
  146.     WHILE NOT Found DO
  147.       IF NOT(Disabled IN GetObject.State(Menu,ChildTitle)) THEN
  148.         WHILE NOT Found AND (ChildEntry # MotherEntry) AND (ChildEntry # Nil) DO
  149.           IF NOT(Disabled IN GetObject.State(Menu,ChildEntry)) THEN
  150.             Found:= TestEntry(ChildEntry);
  151.           END;
  152.  
  153.           IF Found THEN
  154.             WITH Msg DO
  155.               Type  := MnSelected;
  156.               Id    := Global.ApId;
  157.               Length:= 0;
  158.               Title := ChildTitle;
  159.               Item  := ChildEntry;
  160.             END;
  161.             MenuTNormal(Menu,ChildTitle,FALSE);
  162.             ApplWrite(Global.ApId,16,Msg);
  163.           END;
  164.  
  165.           ChildEntry:= GetObject.Next(Menu,ChildEntry);
  166.         END;
  167.       END;
  168.  
  169.       ChildTitle:= GetObject.Next(Menu,ChildTitle);
  170.       MotherEntry:= GetObject.Next(Menu,MotherEntry);
  171.       ChildEntry:= GetObject.Head(Menu,MotherEntry);
  172.  
  173.       IF ChildTitle = MotherTitle THEN
  174.         RETURN FALSE;
  175.       END;
  176.     END;
  177.     RETURN Found;
  178.   ELSE
  179.     RETURN FALSE;
  180.   END;
  181. END MenuKey;
  182.  
  183. TYPE CallbackPtr = POINTER TO MenuCallback;
  184.  
  185. CONST About = 9; (* system dependend? *)
  186.  
  187. VAR BugAction: MenuCallback;
  188.  
  189. PROCEDURE NewMenuAction(Menu: TreePtr; Item: ObjectIndex; Call: MenuCallback);
  190.  
  191. VAR Callback: CallbackPtr;
  192.  
  193. BEGIN
  194.  
  195.   (* bypass GEM bug *)
  196.  
  197.   IF Item = About THEN
  198.     BugAction:= Call;
  199.     RETURN;
  200.   END;
  201.  
  202.   IF Indirect IN GetObject.Flags(Menu,Item) THEN (* just replace caller *)
  203. #if not UNIX
  204.     Callback:= CAST(CallbackPtr,Menu^[Item].ObSpec.Extension^.Parm);
  205. #else
  206.  
  207. #endif
  208.     Callback^:= Call;
  209.   ELSE
  210.     ALLOCATE(Callback,TSIZE(MenuCallback));
  211.     Callback^:= Call;
  212.     IndirectObject(Menu,Item,Callback);
  213.   END;
  214. END NewMenuAction;
  215.  
  216. PROCEDURE MenuAction(Menu: TreePtr; Title: ObjectIndex; Item: ObjectIndex);
  217.  
  218. VAR Callback: POINTER TO MenuCallback;
  219.  
  220. BEGIN
  221.  
  222.   (* bypass GEM bug *)
  223.  
  224.   IF Item = About THEN
  225.     BugAction(Menu,Title);
  226.     RETURN;
  227.   END;
  228.  
  229. #if not UNIX
  230.   Callback:= Menu^[Item].ObSpec.Extension^.Parm;
  231. #else
  232.  
  233. #endif
  234.   Callback^(Menu,Title);
  235. END MenuAction;
  236.  
  237. (*
  238. PROCEDURE MenuTitleOf(Menu: TreePtr; MenuItem: ObjectIndex): ObjectIndex;
  239.  
  240. VAR ParentBox: ObjectPtr;
  241.     FirstBox : ObjectPtr;
  242.     Diff     : ObjectPtr;
  243.  
  244. BEGIN
  245.   ParentBox:= Parent(Menu,MenuItem);
  246.   FirstBox := GetObject.Head(Menu,GetObject.Tail(Menu,Root));
  247.  
  248.   Diff:= 0;
  249.   WHILE FirstBox # ParentBox DO
  250.     INC(Diff);
  251.     FirstBox:= GetObject.Next(Menu,FirstBox);
  252.   END;
  253.  
  254.   RETURN GetObject.Head(Menu,
  255.                         GetObject.Head(Menu,
  256.                                        GetObject.Head(Menu,Root))) + Diff;
  257. END MenuTitleOf;
  258. *)
  259.  
  260. #if not proc_const
  261. BEGIN
  262.   (*NewMenuAction:= NewObjectCallback;*)
  263.   DisposeMenuAction:= DisposeObjectCallback;
  264. #endif
  265. END MenuTool.
  266.